COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002		SUBROUTINE READER
C00019 ENDMK
C⊗;
	SUBROUTINE READER
	COMMON/LN/LINE
	COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
	1,LX,JX,J,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
	COMMON FUNC(512),F2(512),K,I
37	FORMAT(8F)
38	FORMAT(3(A5,A1))
380	FORMAT(I,3(A5,A1))
39	FORMAT(9A5)
	READ (1,39),K,K,AK
C  READS "(512);"
C  LX IS MAIN COUNTER
401	LX=LX+1
1	IF(LINE.EQ.0)READ(1,38,END=4401)XA(LX),Y,FN(LX),H,H
	IF(LINE)READ(1,380,END=4401)K,XA(LX),Y,FN(LX),H,H
	IF(XA(LX).GE.0)GO TO 1
C  TO FIND EOF AFTER COPY SCREWUPS
	IF(FNUM1.EQ.FN(LX))JX=LX
C  JX TELLS WHERE TO FIND FUNCTION TO BE LOOKED AT.
C  XA(LX) IS FUNC. TYPE (SEG OR SYNTH)
	X=0
	N=4
	IF(XA(LX).EQ.'SEG')N=2
	KX=0
C  KX IS LOCAL COUNTER
1401	IF(X.EQ.100)GO TO 401
	KX=KX+1
	IF(LINE.EQ.0)READ(1,37),(AA(K,KX,LX),K=1,N)
	IF(LINE)READ(1,37)AK,(AA(K,KX,LX),K=1,N)
	IF(N.EQ.2)GO TO 2401
	IF(AA(1,KX,LX).EQ.999)GO TO 401
C  FOUND END OF A SYNTH
	GO TO 1401
2401	X=AA(2,KX,LX)
	IF(X.LE.100)GO TO 1401
C  NEXT IS FOR SMOOTHED SEGS
	N=KX+1
	IF(LINE)GO TO 2
	READ(1,37)(AA(K,N,LX),K=1,512)
	GO TO 401
370	FORMAT(9F)
2	DO 3 K=1,512,8
3	READ(1,370)AK,(AA(KX,N,LX),KX=K,K+7)
	GO TO 401
4401	END


	SUBROUTINE READ1
C  READS FIRST LINE OF FILE ONLY
	COMMON/LN/LINE
	COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
	1,LX,JX,JT,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
2151	REWIND 1
CX	CALL FORNAM(FLNM,'FUN')
	CALL OFILE(1,FLNM,'.FUN')
CX  USES MY ROUTINE.  OFILE AND IFILE CAN DO THE SAME.
CC  NOT YET!	CALL IFLE(1,FLNM,'.FUN')
	READ (1,39),X,B
	IF(X.NE.'COMME')GO TO 1
	TYPE 2
	X=-X
1	LINE=0
	IF(X)RETURN
	LINE=-1
C  FOUND LN #S (CAN'T READ SMOOTHS 'THO)
	REREAD 390,LX,X,B
2	FORMAT(' ***** WON''T READ "ET" FILES! *****')
39	FORMAT(A5,10(A1,A3))
390	FORMAT(I,A5,10(A1,A3))
	END

	SUBROUTINE STORE(N)
	COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
	1,LX,JX,J,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
	DO 3090 K=1,KT-1
	DO 3090 L=1,J
3090	AA(L,K,N)=A(K,L)
	RETURN
	END
C  ********** DISPLAY OR PLOT OUTPUT **********
 	SUBROUTINE DPY(F,IY)
	COMMON/RD/ AZ(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
	1,LX,JX,J,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
	DIMENSION H(120)
	COMMON/LT/LPTY,JSEE
	DIMENSION F(1)
	DATA Q/'X'/
	IF(LPTY.NE.5)GO TO 53
	IF(JSEE)GO TO 1
	TYPE 2
	ACCEPT 3,N
	IF(N.NE.'Y')RETURN
1	M=72
CCC	CALL NODM  ! UNDOES  'TTY DM'
	JR=12
	NN=23
	GO TO 7
CC	IF(LPTY.EQ.5)GO TO 7
53	M=120
	JR=29
	NN=59
	WRITE(LPTY,52) FN(JX),FLNM
7	RH=512.0/M
	T=1
	S=2.0/NN+.001
	DO 4 K=1,NN
	R=1.-K*S
	H(1)='!'
	A=' '
	IF(K.EQ.JR)A='-'
6	DO 11 L=2,M
11	H(L)=A
	J=1
	RJ=1
12	DO 9 L=1,M
	A=F(J)
	IF(A.GT.R.AND.A.LE.T)H(L)=Q
	RJ=RJ+RH
9	J=RJ
	T=R
4	WRITE(LPTY,20)(H(L),L=1,M)
	IF(LPTY.EQ.5)GO TO 51
	RETURN  
52	FORMAT(' ************ ',A5,'    FILE = ',A5,'.FUN')
51	TYPE 5
	ACCEPT 3,N
CC	RETURN
20	FORMAT(1X120A1)
2	FORMAT(' SEE IT? '$)
3	FORMAT(A1)
5	FORMAT(' <CR>=CONTINUE'$)
CCC50	CALL YESDM
50	END

	SUBROUTINE PLOTIT(FUNC,EY,P)
	COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
	1,LX,JX,JT,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
	DIMENSION FUNC(1)
	IF(P.EQ.'P')GO TO 1
	IF(P.EQ.0)GO TO 4
	Y=1
	X=2.
CC	IF(P.NE.'X')GO TO 6
CC	X=1.5
CC	Y=.5
6	CALL PLOTS(K)
	P=0
	GO TO 40
1	TYPE 2
	CALL PLOTS(K)
	ACCEPT 3,X
	IF(X.EQ.0)X=SZX
	IF(X.EQ.0)X=1.
	SZX=X
40	SZ=X/5.12
	CALL PLOT(0,17.*SZ,-3)
C  ABOVE FOR COLGATE PLOTTER.
41	S=0
	J=1
	RJK=X/8.
	CALL SYMBOL(SZ,4.*SZ,RJK,FLNM,0,5)
4	CALL SYMBOL(SZ,-3.*SZ,RJK,B(2,JX),0,3)
	CALL PLOT(5.12*SZ,0.,3)
	CALL PLOT(0.,0.,2)
	CALL PLOT(0.,-2.*SZ,3)
	CALL PLOT(0.,2.*SZ,2)

72	CALL PLOT(.01*SZ,FUNC(1)*2.*SZ,3)
	DO 73 K=2,512
	R=K/100.0
73	CALL PLOT(R*SZ,FUNC(K)*2.*SZ,2)
	T=0
	Q=Y+5*SZ
	IF(J.NE.5)GO TO 5
	Q=-S
	T=-7*SZ
5	CALL PLOT(Q,T,-3)
	S=S+Q
	J=J+1
	RETURN

2	FORMAT(' TYPE SIZE - '$)
3	FORMAT(F)
	END

C ******* FOR 'CRUNCH' MODE *********
	SUBROUTINE ZFUNC
	COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
	1,LX,JX,JT,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
	COMMON FUNC(512),F2(512),K,I

43	TYPE 1
	ACCEPT 100,MA,C
	IF(MA.NE.'B')GO TO 76
430	KT=512
C  FOR BACKUP
	RETURN
76	IF(MA.EQ.'A')GO TO 75
	IF(MA.NE.'M')GO TO 73
75	TYPE 39,B
	TYPE 2
	ACCEPT 3,FNM2
	IF(FNM2.EQ.'B')GO TO 43
40	DO 4 K=1,10
5	IF(FNM2.NE.FN(K))GO TO 4
	N2=K
	GO TO 72
4	CONTINUE
	TYPE 74
	GO TO 75
74	FORMAT(' FUNCTION NOT FOUND '/)
72	CALL DPYF(N2,F2)
7	TYPE 60
	ACCEPT 100,K
	IF(K.EQ.'B')GO TO 15
	IF(K.EQ.'N')GO TO 15
	IF(MA.EQ.'M')GO TO 102
70	TYPE 10
	ACCEPT 11,R,R2
	REREAD 100,K
	IF(K.EQ.'B')GO TO 75
	IF(R2.EQ.0)R2=1
	IF(R.EQ.0)R=1
	DO 13 K=1,512
	X=FUNC(K)
	FUNC(K)=FUNC(K)*R+F2(K)*R2+C
13	F2(K)=X
	GO TO 104
73	IF(MA.NE.'C')GO TO 44
	DO 45 K=1,512
	F2(K)=FUNC(K)
45	FUNC(K)=FUNC(K)+C
	GO TO 104
44	IF(MA.NE.'I')GO TO 46
	DO 47 K=1,512
	F2(K)=FUNC(K)
47	FUNC(K)=C-FUNC(K)
	GO TO 104
46	IF(MA.NE.'R')GO TO 75
48	DO 50 K=1,512
50	F2(K)=FUNC(513-K)
	DO 51 K=1,512
	X=FUNC(K)
	FUNC(K)=F2(K)+C
51	F2(K)=X
	GO TO 104
102	DO 103 K=1,512
	X=FUNC(K)
	FUNC(K)=FUNC(K)*F2(K)+C
103	F2(K)=X
104	A(1,2)=520
	CALL NORM(FUNC)
C   NORMALIZES THE FUNCTION
	CALL DPY(FUNC,1)
	TYPE 6
	ACCEPT 100,K
	IF(K.EQ.'M')GO TO 43
	IF(K.NE.'B')RETURN
	DO 14 K=1,512
14	FUNC(K)=F2(K)
15	CALL DPY(FUNC,1)
	GO TO 43
1	FORMAT
     1(' A(DD), M(ULT), R(ETRO), I(NVRT), OR C,N (=ADD CONSTANT N) ',$)
100	FORMAT(A1,F)
2	FORMAT(' 2ND FUNC? ',$)
3	FORMAT(A3)
10	FORMAT(' TYPE RATIO (E.G. 1,2) ',$)
39	FORMAT(10(A1,A3))
11	FORMAT(2F)
6	FORMAT(' F(INISH), OR M(ORE)?  ',$)
60	FORMAT(' GO ON?  ',$)
	END

	SUBROUTINE DPYF(N,F)
	COMMON/S/H,AMP,CON,PH
	COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
	1,LX,JX,JT,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
	DIMENSION F(1)
	NODPY=-1
	IF(N.GT.0)GO TO 8
	N=JX
	NODPY=0
CC COLGATE 6/74--SEE MAIN AT 1201-18	IF(XA(N).EQ.'SEG')GO TO 5
8	IF(XA(N).NE.'SYNTH')GO TO 5
	CALL ZERO(F)
	K=1
1	AMP=AA(2,K,N)
	H=AA(1,K,N)
	PH=AA(3,K,N)
	CON=AA(4,K,N)
	CALL SYN(F)
	K=K+1
	IF(AA(1,K,N).NE.999)GO TO 1
	CALL NORM(F)
	GO TO 4

5	K=1
	G=AA(2,1,N)
	IF(G.EQ.520)GO TO 6
	J=1
	IF(G.LE.1)GO TO 22
	Y=0
	K=0
C  FOR START BEYOND STEP 1 - ASSUMES A 0,1.
	GO TO 2
22	Y=AA(1,1,N)
2	K=K+1
	M=AA(2,K,N)*5.12+.5
	IF(M.GT.512)GO TO 6
	G=AA(1,K,N)
	Z=G-Y
	H=M-J+1
	IF(H.LT.1)H=1
	NN=0
	DO 3 L=J,M
	F(L)=(NN*Z)/H+Y
3	NN=NN+1
	IF(M.EQ.512)GO TO 4
	Y=G
	J=M+1
	GO TO 2
C  FOR LONG FUNCS.
6	L=K+1
	DO 7 M=1,512
7	F(M)=AA(M,L,N)
4	IF(NODPY)CALL DPY(F,-1)
C  NODPY=0 IS FOR PLOTTER AND LPT
C  NOW FUNCTION IS FULL AND DISPLAYED
	END

	SUBROUTINE SYN(F)
	COMMON/S/H,AMP,CON,PH
	DIMENSION F(1)
	DATA FAC/0.703125/,FACP/1.422222/
	X=PH*FACP+1.0
C  PHASE IS IN DEGREES (0 - 360)
2016	DO 17 L=1,512
	XL=SIND(X*FAC)*AMP+CON
	IF(CON.LT.100.0)GO TO 1
	F(L)=(XL-100.)*F(L)
	GO TO 2
1	F(L)=F(L)+XL
C   NORMALIZES THE FUNCTION
2	X=X+H
17	IF(X.GT.512.)X=X-512.
	RETURN
	END

	SUBROUTINE ZERO(F)
	DIMENSION F(1)
	DO 1 K=1,512
1	F(K)=0
	RETURN
	END

	SUBROUTINE NORM(F)
	DIMENSION F(1)
	X=F(1)
C   NORMALIZES THE FUNCTION
	DO 19 K=2,512
	XK=ABS(F(K))
19	IF(X.LT.XK)X=XK
	DO 20 K=1,512
20	F(K)=F(K)/X
	RETURN
	END
	SUBROUTINE SSS(VV,N1,A1)
	DIMENSION V(50,4),A1(512),C(30,4),YP(30),J(30),NX(3),KA(14),K(9)
	DIMENSION VV(50,4)
	EQUIVALENCE(K1,K(1)),(K2,K(2)),(K3,K(3)),(K4,K(4)),(K5,K(5)),
     1	(K6,K(6)),(K7,K(7)),(K8,K(8)),(K9,K(9))
	DATA KA/1,2,2,1,1,2,1,1,0,2,1,-1,0,1/,DX/.00001/
	IF(VV(1,2).EQ.0) VV(1,2)=1
	DO 5 I=1,30
	DO 5 L=1,2
5	V(I,L)=VV(I,L)
	NX(1)=N1
698	NX(2)=NX(1)-1
	DO 10 I=1,NX(1)
10	V(I,2)=(V(I,2)-1)/99.
	DO 20 I=2,NX(2)
	JX=I+1
	JZ=I-1
	YP(I)=(V(JX,1)-V(JZ,1))/(V(JX,2)-V(JZ,2))
20	IF((V(JX,1)-V(I,1))*(V(I,1)-V(JZ,1)).LE.0) YP(I)=0
	DO 22 I=1,9
22	K(I)=KA(I)
	KOUNT=0
21	KOUNT=KOUNT+1
	V1=V(K2,1)-V(K1,1)
	V2=V(K2,2)-V(K1,2)
802	IF((YP(K2)-V1/V2)*(V(K3,1)-V(K4,1)).GT.0) GO TO 30
24	Z=V(K2,K5)+(V(K1,K6)-V(K2,K6))*YP(K2)**K7
	IF(YP(K2)**2.LT.DX.AND.V1**2.LT.DX) GO TO 36
	IF(YP(K2)**2.LT.DX) GO TO 38
	D1=V(K2,K5)-Z
806	D2=Z-V(K1,K5)
	ZZ=(V(K1,K6)*D2+V(K2,K6)*D1)/(D1+D2)
808	YP(K1)=(ZZ*K9+V(K2,1)*K8-V(K1,1))/
     1	(ZZ*K8+V(K2,2)*K9-V(K1,2))
	GO TO 40
30	DO 32 I=5,9
32	K(I)=KA(I+5)
	GO TO 24
36	YP(K1)=0
	GO TO 40
38	YP(K1)=-100
	IF(KOUNT.EQ.2) GO TO 39
	IF(V(K2,1).GT.V(K1,1)) YP(K1)=100
	GO TO 40
39	IF(V(K2,1).LT.V(K1,1)) YP(K1)=100
40	IF(KOUNT.EQ.2) GO TO 50
	DO 42 I=1,2
	K(I)=NX(I)
42	K(I+2)=K(I)     
	DO 44 I=5,9
44	K(I)=KA(I)
	GO TO 21
50	NX(3)=NX(2)-1
	N=1
52	N=N+1
	IF(N.GT.NX(3)) GO TO 92
	JX=N+1
	V1=V(JX,1)-V(N,1)
	V2=V(JX,2)-V(N,2)
	Y1=YP(N)-YP(JX)
	IF(Y1**2.LT.DX.AND.V1**2.GT.DX) GO TO 720
710	X=(V1-YP(JX)*V(JX,2)+YP(N)*V(N,2))/Y1                   
715	IF(X.GE.V(N,2).AND.X.LE.V(JX,2)) GO TO 52      
	IF(Y1**2.LT.DX.AND.V1**2.LT.DX) GO TO 52
720	DO 120 I=NX(1),JX,-1
	JZ=I+1
	V(JZ,2)=V(I,2)
	V(JZ,1)=V(I,1)
120	YP(JZ)=YP(I)
	YP(JX)=.5*V1/V2
	IF(V1*(YP(N)-V1/V2).LE.0) YP(N+1)=4*YP(JX)
	V(JX,2)=.5*(V(N+2,2)+V(N,2))
	V(JX,1)=.5*(V(N+2,1)+V(N,1))
	N=JX
	DO 88 L=1,3
88	NX(L)=NX(L)+1
  	GO TO 52
92	DO 140 I=1,NX(2)
	JX=I+1
	W0=YP(I)
	W1=YP(JX)
	W2=V(JX,2)-V(I,2)
	W3=V(JX,1)-V(I,1)
	C(I,1)=(W2*(W0+W1)-2*W3)/(W0-W1)
	C(I,2)=W2-C(I,1)
	C(I,4)=W0*C(I,2)
140	C(I,3)=-C(I,4)+W3
730	DO 150 I=1,NX(1)
150	J(I)=511*V(I,2)+1
740	DO 160 I=1,NX(2)
	L1=J(I)+1
	IF(I.EQ.1) L1=1
	ZZ=C(I,2)
	XX=C(I,1)
	L2=J(I+1)
750	DO 160 L=L1,L2
	X=(FLOAT(L)-1.)/511.
	IF(XX**2.LT.DX) GO TO 155
	ZX=.5*SQRT(ZZ**2-4*XX*(V(I,2)-X))/XX
	T1=-.5*ZZ/XX+ZX
	T2=T1-2*ZX
	IF(T2.GT.-DX.AND.T2.LT.(1+DX)) T1=T2
155	IF(XX**2.LT.DX) T1=-(V(I,2)-X)/ZZ
160   	A1(L)=C(I,3)*T1**2+C(I,4)*T1+V(I,1)
770	END

C THIS ROUTINE ALLOWS NAMES OF FROM 1 TO 5 LETTERS TO BE USED.
C NO EXTENSIONS CAN BE USED.  IFI RETURNS INFO RE. LINE NUMS.
C READS SOS, ET AND OTHER FILES WITHOUT LINE NUMS.
	SUBROUTINE IFILE(I,N)
	EQUIVALENCE (NN,NAME),(NN2,NN(2))
	COMMON /NN/NN(2) /IFI/IFI
	DOUBLE PRECISION NAME
	DATA NN2/'.'/
	NN(1)=N
	OPEN(UNIT=I,FILE=NAME)
	IF(NN2.NE.'.')GO TO 1
C JUMP IF COMING FROM OFILE CALL
	READ(I,2)K,J
	IFI=-1
	IF(K.NE.'00')GO TO 3
	IFI=0 
C IFI = 0 = LINE NUMBERS.
5	OPEN(UNIT=I,FILE=NAME)
C REOPEN IF LINE NUMS.
	GO TO 1
3	IF(K.NE.'CO')GO TO 5
	IF(J.NE.'MMENT')GO TO 5
4	READ(I,2)K,J
C READS COMMENTS ON DIRECTORY PAGE.
	IF(J.NE.';')GO TO 4
2	FORMAT(A2,A5)
1	NN2='.'
	END
	SUBROUTINE OFILE(I,N,IEXT)
	COMMON /NN/NN(2)
	NN(2)=IEXT
	CALL IFILE(I,N)
	END